Amiga Plus 2000 #5/Amiga Plus CD - 2000 - No. 5.iso/Tools/Dev/fpc/oop/ExecObject.pas.bak

Text File | 2000-01-01 | 12.9 KB | 540 lines

unit ExecObject;


interface

uses Exec,amigalib,strings;



type
    pExecObject = ^tExecObject;
    tExecObject = object
        public
        constructor Create;
        destructor Free;
        {
          We can't have overlay functions in the
          current amiga version. Have to change
          this later. (Add and AddS)
        }
        function AddS( s : string): pNode;
        function Add(s : PChar): pNode;
        procedure PrintList;
        function Count: integer;
        function TheList: pList;
        procedure Clear;
        procedure Delete( node : pNode);
        { Have to change FindS and Find }
        function FindS(data : string): pNode;
        function Find(data : PChar): pNode;
        function First: pNode;
        function Last: pNode;
        function Next(node : pNode): pNode;
        function GetData(node : pNode): pChar;
        function IndexOf( num : integer): pNode;
        function Prev( node : pNode): pNode;
        function InsertS( data : string; node : pNode): pNode;
        function Insert( data : PChar; node : pNode): pNode;
        procedure ToBuffer(var buf: PChar);
        procedure Bottom(node : pNode);
        procedure Down(node : pNode);
        procedure Top(node : pNode);
        procedure Up(node : pNode);
        procedure DeleteLast;

        procedure DeleteDup;
        function SizeOfList: longint;
        procedure Sort;
        function UpDateS(node : pNode; data : string): boolean;
        function UpDate(node : pNode; data : PChar): boolean;
        function FileToList(thefile : PChar): boolean;
        function FileToListS(thefile : String): boolean;
        function ListToFile(TheFile : PChar): Boolean;
        function ListToFileS(TheFile : String): Boolean;
         {
        function Copy: pList;
        }
        private
        elist : pList;
        number  : integer;
        totalsize : longint;
        procedure Error(err : integer);
        end;

implementation

constructor tExecObject.Create;
begin
    elist := nil;
    New(elist);
    NewList(elist);
    number := 0;
end;

destructor tExecObject.Free;
var
    temp : pNode;
begin
    while elist^.lh_Head <> @elist^.lh_Tail do begin
       temp := pNode(elist^.lh_Head);
       if assigned(temp) then begin
           if assigned(temp^.ln_Name) then begin
              { writeln('freeing ',temp^.ln_Name);}
               StrDispose(temp^.ln_Name);
           end;
           RemHead(elist);
           Dispose(temp);
       end;
    end;
    if assigned(elist) then begin
     {  writeln('freeing the list');}
       Dispose(elist);
       elist := nil;
    end;
end;

function tExecObject.AddS( s : string): pNode;
var
    temp : pNode;
begin
    New(temp);
    temp^.ln_Name := StrAlloc(Length(s)+1);
    if Assigned(temp^.ln_Name) then begin
        StrPCopy(temp^.ln_Name,s);
        temp^.ln_Type := 0;
        temp^.ln_Pri := 0;
        AddTail(elist,temp);
        inc(number);
        AddS := temp;
    end else AddS := nil;
end;

function tExecObject.Add( s : PChar): pNode;
var
    temp : pNode;
begin
    New(temp);
    temp^.ln_Name := StrAlloc(StrLen(s)+1);
    if Assigned(temp^.ln_Name) then begin
        StrCopy(temp^.ln_Name,s);
        temp^.ln_Type := 0;
        temp^.ln_Pri := 0;
        AddTail(elist,temp);
        inc(number);
        Add := temp;
    end else Add := nil;
end;

procedure tExecObject.PrintList;
var
   temp : pNode;
   i : integer;
begin
   temp := elist^.lh_Head;
   for i := 1 to Count do begin
      if assigned(temp^.ln_Name) then writeln('Node ',i,': ',temp^.ln_Name);
      temp := temp^.ln_Succ;
   end;
end;

function tExecObject.Count: Integer;
begin
   Count := number;
end;

function tExecObject.TheList: pList;
begin
   TheList := elist;
end;

procedure tExecObject.Error(err : integer);
begin
   Halt(err);
end;

procedure tExecObject.Clear;
var
    temp : pNode;
begin
    while elist^.lh_Head <> @elist^.lh_Tail do begin
        temp := elist^.lh_Head;
        if assigned(temp) then begin
            if assigned(temp^.ln_Name) then StrDispose(temp^.ln_Name);
            RemHead(elist);
            Dispose(temp);
        end;
    end;
end;

procedure tExecObject.Delete( node : pNode);
begin
   if assigned(node) then begin
      if assigned(node^.ln_Name) then StrDispose(node^.ln_Name);
      Remove(node);
      Dispose(node);
      dec(number);
   end;
end;

function tExecObject.FindS(data : string): pNode;
var
   temp : pNode;
   result : pNode;
   p : PChar;
begin
   result := nil;
   p := StrAlloc(length(data)+1);
   StrPCopy(p,data);
   if elist^.lh_Head^.ln_Succ <> nil then begin
      temp := elist^.lh_Head;
      while (temp^.ln_Succ <> nil) do begin
          if (StrIComp(temp^.ln_Name,p)=0) then begin
              result := temp;
              break;
          end;
          temp := temp^.ln_Succ;
      end;
   end;
   StrDispose(p);
   FindS := result;
end;

function tExecObject.Find(data : PChar): pNode;
var
   temp : pNode;
   result : pNode;
begin
   result := nil;
   if elist^.lh_Head^.ln_Succ <> nil then begin
      temp := elist^.lh_Head;
      while (temp^.ln_Succ <> nil) do begin
          if (StrIComp(temp^.ln_Name,data)=0) then begin
              result := temp;
              break;
          end;
          temp := temp^.ln_Succ;
      end;
   end;
   Find := result;
end;

function tExecObject.First: pNode;
var
   head : pNode;
begin
   head := elist^.lh_Head;
   if assigned(head^.ln_Succ) then First := head
   else First := nil;
end;

function tExecObject.Last: pNode;
var
   tail : pNode;
begin
   tail := elist^.lh_TailPred;
   if assigned(tail^.ln_pred) then Last := tail
   else Last := nil;
end;

function tExecObject.Next(node : pNode): pNode;
var
   nxt : pNode;
begin
   nxt := node^.ln_Succ;
   if assigned(nxt^.ln_Succ) then Next := nxt
   else Next := nil;
end;

function tExecObject.GetData(node : pNode): pChar;
begin
   if assigned(node) then begin
      if assigned(node^.ln_Name) then GetData := node^.ln_Name
      else GetData := nil;
   end;
end;

function tExecObject.IndexOf( num : integer): pNode;
var
   node : pNode;
   i : integer;
begin
   if num <=Count then begin
      node := elist^.lh_Head;
      for i := 1 to num do begin
         node := node^.ln_Succ;
      end;
      IndexOf := node;
   end else IndexOf := nil;
end;

function tExecObject.Prev( node : pNode): pNode;
var
   pred : pNode;
begin
   pred := node^.ln_Pred;
   if assigned(pred^.ln_Pred) then Prev := pred
   else Pred := nil;
end;

function tExecObject.InsertS( data : string; node : pNode): pNode;
var
   temp : pNode;
begin
   temp := AddS(data);
   if assigned(temp) then begin
      if assigned(node) then begin
          Remove(temp);
          ExecInsert(elist,temp,node);
      end;
      InsertS := temp;
   end else InsertS := nil;
end;

function tExecObject.Insert( data : PChar; node : pNode): pNode;
var
   temp : pNode;
begin
   temp := Add(data);
   if assigned(temp) then begin
      if assigned(node) then begin
          Remove(temp);
          ExecInsert(elist,temp,node);
      end;
      Insert := temp;
   end else Insert := nil;
end;

procedure tExecObject.ToBuffer(var buf: PChar);
var
   i : integer;
   temp : pNode;
begin
   buf[0] := #0;
   temp := elist^.lh_Head;
   for i := 1 to number do begin
      if assigned(temp^.ln_Name) then begin
         strcat(buf,temp^.ln_Name);
         if i < number then strCat(buf,PChar(';'#0));
      end;
      temp := temp^.ln_Succ;
   end;
end;

procedure tExecObject.Bottom(node : pNode);
begin
   if assigned(node) then begin
      Remove(node);
      AddTail(elist,node);
   end;
end;

procedure tExecObject.Down(node : pNode);
var
   succ : pNode;
begin
   succ := node^.ln_Succ;
   if assigned(node) and assigned(succ) then begin
      Remove(node);
      ExecInsert(elist,node,succ);
   end;
end;

procedure tExecObject.Top(node : pNode);
begin
   if assigned(node) then begin
      Remove(node);
      AddHead(elist,node);
   end;
end;

procedure tExecObject.Up(node : pNode);
var
   pred : pNode;
begin
   pred := node^.ln_Pred;
   if assigned(node) and assigned(pred) then begin
      pred := pred^.ln_Pred;
      Remove(node);
      ExecInsert(elist,node,pred);
   end;
end;
procedure tExecObject.DeleteLast;
var
   temp : pNode;
begin
   temp := elist^.lh_TailPred;
   if assigned(temp) then begin
      if assigned(temp^.ln_Name) then StrDispose(temp^.ln_Name);
      RemTail(elist);
      Dispose(temp);
      dec(number);
   end;
end;

procedure tExecObject.DeleteDup;
var
   temp : pNode;
   nxt  : pNode;
begin
   temp := elist^.lh_Head;
   while assigned(temp^.ln_Succ) do begin
      nxt := temp^.ln_Succ;
      if (StrIComp(temp^.ln_Name,nxt^.ln_Name)=0) then begin
         Delete(temp);
      end;
      temp := nxt;
   end;
end;

function tExecObject.SizeOfList: longint;
var
   temp : pNode;
   tsize : longint;
   i : integer;
begin
   tsize := 0;
   temp := elist^.lh_Head;
   for i := 1 to number do begin
      if assigned(temp^.ln_Name) then tsize := tsize + (StrLen(temp^.ln_Name));
      temp := temp^.ln_Succ;
   end;
   SizeOfList := tsize;
end;

procedure tExecObject.Sort;
VAR
    notfinished : BOOLEAN;
    tfirst, second : pNode;
    n   : Longint;

BEGIN
    IF assigned(elist^.lh_Head^.ln_Succ) then begin
        notfinished := True;
        WHILE (notfinished) DO BEGIN
            notfinished := FALSE;
            tfirst := elist^.lh_Head;
            IF assigned(tfirst) THEN BEGIN
                n := 1;
                second := tfirst^.ln_Succ;
                WHILE n <> number DO BEGIN
                    n := n + 1;
                    IF (StrIComp(tfirst^.ln_Name,second^.ln_Name)>0) THEN BEGIN
                        Remove(tfirst);
                        ExecInsert(elist,tfirst,second);
                        notfinished := True;
                    END ELSE
                        tfirst := second;
                    second := tfirst^.ln_Succ;
                END;
            END;
        END;
    END;
END;


function tExecObject.UpDateS(node : pNode; data : string): boolean;
var
   result : boolean;
begin
   if assigned(node^.ln_Succ) then begin
      if assigned(node^.ln_Name) then begin
         StrDispose(node^.ln_Name);
         node^.ln_Name := StrAlloc(length(data)+1);
         if assigned(node^.ln_Name) then begin
            StrPCopy(node^.ln_Name,data);
            result := true;
         end else result := false;
      end;
      UpDateS := result;
   end;
end;

function tExecObject.UpDate(node : pNode; data : PChar): boolean;
var
   result : boolean;
begin
   if assigned(node^.ln_Succ) then begin
      if assigned(node^.ln_Name) then begin
         StrDispose(node^.ln_Name);
         node^.ln_Name := StrAlloc(strlen(data)+1);
         if assigned(node^.ln_Name) then begin
            StrCopy(node^.ln_Name,data);
            result := true;
         end else result := false;
      end;
      UpDate := result;
   end;
end;

function tExecObject.FileToList(thefile : PChar): boolean;
begin
    FileToList := FileToListS(strpas(thefile));
end;

function tExecObject.FileToListS(thefile : String): boolean;
var
   Inf : Text;
   temp : pNode;
   buffer : PChar;
   buf : Array [0..500] of Char;
begin
   buffer := @buf;
   Assign(Inf, thefile);
   {$I-}
   Reset(Inf);
   {$I+}
   if IOResult = 0 then begin
      while not eof(Inf) do begin
      { I don't want end of lines here (for use with amiga listviews)
        just change this if you need newline characters.
      }
         Read(Inf, buffer);
         temp := Add(buffer);
         Readln(inf, buffer);
      end;
      CLose(Inf);
      FileToListS := true;
   end else FileToListS := false;
end;

function tExecObject.ListToFile(TheFile : PChar): Boolean;
begin
    ListToFile := ListToFileS(strpas(TheFile));
end;

function tExecObject.ListToFileS(TheFile : String): Boolean;
VAR
    Out      : Text;
    dummy    : Longint;
    temp     : pNode;
begin
    Assign(Out, TheFile);
    {$I-}
    Rewrite(Out);
    {$I+}
    if IOResult = 0 then begin
       IF number > 0 THEN BEGIN
          temp := elist^.lh_Head;
          FOR dummy := 1 TO number DO BEGIN
             IF temp^.ln_Name <> NIL THEN BEGIN
                {
                  Have to check the strlen here, if it's an
                  empty pchar fpc will write out a #0
                }
                if strlen(temp^.ln_Name) > 0 then
                   WriteLN(Out,temp^.ln_Name)
                else writeln(Out);
             END;
             temp := temp^.ln_Succ;
          END;
        END;
        Close(Out);
        ListToFileS := True;
    END Else ListToFileS := False;
END;


end.